home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl5 / auto / RPC / XML / Procedure / call.al < prev    next >
Encoding:
Text File  |  2008-11-04  |  3.2 KB  |  84 lines
  1. # NOTE: Derived from blib/lib/RPC/XML/Procedure.pm.
  2. # Changes made here will be lost when autosplit is run again.
  3. # See AutoSplit.pm.
  4. package RPC::XML::Procedure;
  5.  
  6. #line 891 "blib/lib/RPC/XML/Procedure.pm (autosplit into blib/lib/auto/RPC/XML/Procedure/call.al)"
  7. ###############################################################################
  8. #
  9. #   Sub Name:       call
  10. #
  11. #   Description:    Encapsulates the invocation of the code block that the
  12. #                   object is abstracting. Manages parameters, signature
  13. #                   checking, etc.
  14. #
  15. #   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
  16. #                   $self     in      ref       Object of this class
  17. #                   $srv      in      ref       An object derived from the
  18. #                                                 RPC::XML::Server class
  19. #                   @dafa     in      list      The params for the call itself
  20. #
  21. #   Globals:        None.
  22. #
  23. #   Environment:    None.
  24. #
  25. #   Returns:        Success:    value
  26. #                   Failure:    dies with RPC::XML::Fault object as message
  27. #
  28. ###############################################################################
  29. sub call
  30. {
  31.     my ($self, $srv, @data) = @_;
  32.  
  33.     my (@paramtypes, @params, $signature, $resptype, $response, $name, $noinc);
  34.  
  35.     $name = $self->name;
  36.     # Create the param list.
  37.     # The type for the response will be derived from the matching signature
  38.     @paramtypes = map { $_->type  } @data;
  39.     @params     = map { $_->value } @data;
  40.     $signature = join(' ', @paramtypes);
  41.     $resptype = $self->match_signature($signature);
  42.     # Since there must be at least one signature with a return value (even
  43.     # if the param list is empty), this tells us if the signature matches:
  44.     return RPC::XML::fault->new(301,
  45.                                 "method $name has no matching " .
  46.                                 'signature for the argument list: ' .
  47.                                 "[$signature]")
  48.         unless ($resptype);
  49.  
  50.     # Set these in case the server object is part of the param list
  51.     local $srv->{signature} = [ $resptype, @paramtypes ];
  52.     local $srv->{method_name} = $name;
  53.     # If the method being called is "system.status", check to see if we should
  54.     # increment the server call-count.
  55.     $noinc = (($name eq 'system.status') && @data &&
  56.               ($paramtypes[0] eq 'boolean') && $params[0]) ? 1 : 0;
  57.     # For RPC::XML::Method (and derivatives), pass the server object
  58.     unshift(@params, $srv) if ($self->isa('RPC::XML::Method'));
  59.  
  60.     # Now take a deep breath and call the method with the arguments
  61.     eval { $response = $self->{code}->(@params); };
  62.     # On failure, propagate user-generated RPC::XML::fault exceptions, or
  63.     # transform Perl-level error/failure into such an object
  64.     if ($@)
  65.     {
  66.         return UNIVERSAL::isa($@, 'RPC::XML::fault') ?
  67.             $@ :
  68.             RPC::XML::fault->new(302, "Method $name returned error: $@");
  69.     }
  70.  
  71.     $self->{called}++ unless $noinc;
  72.     # Create a suitable return value
  73.     if ((! ref($response)) && UNIVERSAL::can("RPC::XML::$resptype", 'new'))
  74.     {
  75.         my $class = "RPC::XML::$resptype";
  76.         $response = $class->new($response);
  77.     }
  78.  
  79.     $response;
  80. }
  81.  
  82. 1;
  83. # end of RPC::XML::Procedure::call
  84.